perm filename 12TONE.OLD[OLD,LCS] blob
sn#187345 filedate 1976-08-07 generic text, type T, neo UTF8
00010 C****---- SELF-CONTAINED VERSION --- GOOD AS OF 11/75 ---- ********
00100 C ********** MATRIX FEB. 16,73 ******** PRINTS 12-TONE CHART ******
00200 C 'S'EARCH WILL LOCATE ROW SOURCES OF CHORDS, ETC.
00300 COMMON INV(12),IR(12),N(12),J(13,13),ISCAL(12),IS2(12),
00400 1 INP2(72),INP(72),NRW
00500 1,IC(6),ISQ(25,25),NAME(10),INOT(49),JA(12)
00600 DATA ISCAL/'C','C#','D','D#','E','F','F#','G','G#',
00700 1 'A','A#','B'/,INV/'I0','I1','I2','I3','I4','I5','I6','I7',
00800 1 'I8','I9','I10','I11'/,IR/'P0','P1','P2','P3','P4',
00900 1 'P5','P6','P7','P8','P9','P10','P11'/
01000 DATA IS2/'C','$','D','$','E','F','$','G','$','A','$','B'/
01100 C N=NEW ROW, T=TYPE MATRIX, L=LPT, S=SEARCH, R=READ FILE 'ROWS', W=WRITE
01200 662 TYPE 61
01300 ACCEPT 1,NRW
01400 IF(NRW.EQ.'L'.OR.NRW.EQ.'M')GO TO 62
01500 C 'M' IS FOR OUTPUT TO MSS PROG.
01600 IF(NRW.EQ.'T')GO TO 1188
01700 IF(NRW.NE.'R'.AND.NRW.NE.'W')GO TO 6620
01800 CALL RDWRT
01900 C WE'VE JUST READ IN A ROW.
02000 6620 IF(NRW.NE.'S')GO TO 64
02100 663 TYPE 65
02200 GO TO 661
02300 65 FORMAT(' TYPE NOTES'/)
02400 61 FORMAT(/' N=NEW, T=TYPE MTRX, S=SRCH, R=RD, W=WRT, L=LST'/)
02500 300 FORMAT(' PRINT HOW MANY?'/)
02600 200 FORMAT(' TYPE NAME OF WORK'/)
02700 62 KREP=0
02800 TYPE 300
02900 ACCEPT 400,KREP
03000 1188 KREP=KREP-1
03100 JOUT=3
03200 IF(NRW.EQ.'T')JOUT=5
03300 GO TO 288
03400 64 HEX=-10
03500 J(2,1)=INV(1)
03600 J(1,2)=IR(1)
03700 IF(NRW.EQ.'R')GO TO 661
03800 TYPE 200
03900 ACCEPT 444,NAME
04000 188 TYPE 100
04100 661 JOUT=5
04200 FIRST=-1.
04300 IF(NRW.EQ.'R')GO TO 6650
04400 ACCEPT 1,INP2
04500 IF(NRW.EQ.'S')GO TO 498
04600 6650 DO 665 KGZ=1,72
04700 665 INP(KGZ)=INP2(KGZ)
04800 GO TO 198
04900 C IF A 13TH NOTE IS ADDED, THEN NO PRINTOUT.
05000 C TYPE 'S' TO SEARCH, 'SP' OUTPUTS TO LPT.
05100 498 K=0
05200 JS=0
05300 ISQ2=0
05400 298 K=K+1
05500 DID=0
05600 IF(K.GT.72)GO TO 8888
05700 L=INP2(K)
05800 IF(L.EQ.' ')GO TO 298
05900 DO 888 M=1,12
06000 IF(L.NE.IS2(M))GO TO 888
06100 LL=M
06200 K=K+1
06300 IF(INP2(K).EQ.'S')LL=M+1
06400 IF(INP2(K).EQ.'F')LL=M-1
06500 ISQ2=ISQ2+2**LL
06600 C ASSIGNS # TO EACH NOTE
06700 JS=JS+1
06800 C JS IS # OF NOTES IN GROUP TO BE FOUND.
06900 GO TO 298
07000 888 CONTINUE
07100 8888 IF(JS.EQ.0)CALL EXIT
07200 C NO NOTES WERE GIVEN.
07300 IF(FIRST)LGRP=JS
07400 FIRST=0
07500 C SAVE # OF NOTES TO BE FOUND.
07600 JGRP=JS-1
07700 DO 333 NN=1,2
07800 DO 333 K=1,13
07900 C '+JGRP' IS FOR WRAP-AROUND
08000 JQ=2
08100 DO 222 L=1,12
08200 KQ=L
08300 C SETS # OF 1ST NOTE OF FOUND GROUP.
08400 LL=0
08500 DO 223 KK=JQ,JQ+JGRP
08600 NR=KK
08700 NI=K
08800 IF(NN.EQ.1)GO TO 223
08900 NR=K
09000 NI=KK
09100 223 LL=LL+ISQ(NR,NI)
09200 2223 IF(LL.EQ.ISQ2)GO TO 334
09300 222 JQ=JQ+1
09400 GO TO 333
09500 334 NR=1
09600 IF(LGRP.NE.JS)TYPE 67,JS
09700 LGRP=JS
09800 C NN=1, R FORMS. NN=2, I FORMS.
09900 IF(NN.EQ.1)GO TO 2334
10000 NI=1
10100 NR=K
10200 C K WILL BE 1ST NOTE OF GROUP IN ROW.
10300 2334 WRITE(JOUT, 66),J(NR,NI),KQ
10400 DID=-1.
10500 333 CONTINUE
10600 IF(DID)GO TO 3333
10700 IF(JGRP.NE.1)GO TO 3334
10800 C DON'T TRY AGAIN IF GROUP IS DOWN TO 2.
10900 TYPE 67,JGRP
11000 GO TO 3333
11100 3334 DO 398 K=72,1,-1
11200 IF(INP2(K).EQ.' ')GO TO 398
11300 3398 INP2(K)=' '
11400 INP2(K-1)=' '
11500 GO TO 498
11600 398 CONTINUE
11700 C ABOVE SHORTENS GROUP BY ONE.
11800 3333 TYPE 60
11900 GO TO 662
12000 198 JJ=1
12100 K=0
12200 98 K=K+1
12300 IF(K.GT.72)GO TO 9999
12400 L=INP(K)
12500 IF(L.EQ.' ')GO TO 98
12600 IF(JJ.EQ.14)GO TO 99
12700 C ANYTHING TYPED AFTER 12 NOTES CAUSES 'NOPRIN'.
12800 DO 999 M=1,12
12900 IF(L.NE.IS2(M))GO TO 999
13000 LL=M
13100 K=K+1
13200 IF(INP(K).EQ.'S')LL=M+1
13300 IF(INP(K).EQ.'F')LL=M-1
13400 JA(JJ)=LL
13500 C SAVES #S FOR NOTATION
13600 JJ=JJ+1
13700 J(JJ,2)=LL
13800 ISQ(JJ,2)=2**LL
13900 C SETS VALUE AS POWER OF 2 FOR EACH NOTE.
14000 GO TO 98
14100 999 CONTINUE
14200 99 CONTINUE
14300
14400 9999 IF(JJ.EQ.1)CALL EXIT
14500 C NO NOTES WERE GIVEN.
14600 I=J(2,2)
14700 C WORKS OUT MATRIX
14800 DO 9 K=3,13
14900 LL=J(K,2)-I+1
15000 IF(LL.LE.0)LL=LL+12
15100 9 J(K,1)=INV(LL)
15200 DO 2 K=2,12
15300 2 N(K)=J(K+1,2)-I
15400 DO 3 K=3,13
15500 LL=I-N(K-1)
15600 IF(LL.LT.1)LL=LL+12
15700 IF(LL.GT.12)LL=LL-12
15800 ISQ(2,K)=2**LL
15900 J(2,K)=LL
16000 LL=LL+1-I
16100 IF(LL.LE.0)LL=LL+12
16200 3 J(1,K)=IR(LL)
16300 DO 4 K=3,13
16400 DO 4 I=3,13
16500 LL=J(2,I)+N(K-1)
16600 IF(LL.LT.1)LL=LL+12
16700 IF(LL.GT.12)LL=LL-12
16800 ISQ(K,I)=2**LL
16900 4 J(K,I)=ISCAL(LL)
17000 DO 7 K=2,13
17100 7 J(K,2)=ISCAL(J(K,2))
17200 DO 8 K=3,13
17300 8 J(2,K)=ISCAL(J(2,K))
17400 10 J(1,1)=0
17500 DO 28 K=2,13
17600 DO 28 L=2,13
17700 KQ=ISQ(K,L)
17800 ISQ(K+12,L)=KQ
17900 28 ISQ(K,L+12)=KQ
18000 C +12 FOR WRAP-AROUND
18100 288 IF(NRW.EQ.'M')CALL MSS12
18200 C MSS12 MAKES FILE FOR MSS PROG.
18300 WRITE(JOUT, 60),NAME
18400 WRITE(JOUT, 60)
18500 C NEXT JUMPS OVER NOTATION PRINT.
18600 GO TO 5557
18700 C UNTIL 210, PRINTS NOTATION
18800 G=' '
18900 WRITE(JOUT, 201),G
19000 L=5
19100 DO 202 IJ=1,7
19200 LN=-1
19300 IF(IJ.EQ.2.OR.IJ.EQ.4.OR.IJ.EQ.6)LN=0
19400 C LINE OR SPACE
19500 JK=2
19600 IF(IJ.EQ.1.OR.IJ.EQ.4)JK=1
19700 DO 203 IQ=1,JK
19800 204 DO 205 K=1,49
19900 205 INOT(K)=' '
20000 DO 206 K=1,12
20100 IF(JA(K).NE.L)GO TO 206
20200 C SKIPS IF NO NOTE NOW
20300 IK=K
20400 L=L-1
20500 IF(L.EQ.0)L=12
20600 M=K*4-1
20700 IF(IK.GT.6)M=M+2
20800 2000 INOT(M)='O'
20900 IF(L.EQ.3.OR.L.EQ.1.OR.L.EQ.10.OR.L.EQ.8.OR.
21000 1 L.EQ.6)INOT(M-1)='#'
21100 IF(L.EQ.2.OR.L.EQ.12.OR.L.EQ.9.OR.L.EQ.7.OR.
21200 1 L.EQ.5)LN=0
21300 GO TO 208
21400 206 CONTINUE
21500 208 IF(LN)WRITE(JOUT, 209),(INOT(IZ),IZ=1,M)
21600 C OVERPRINTS
21700 203 IF(LN.EQ.0)WRITE(JOUT, 210),(INOT(IZ),IZ=1,M)
21800 G=' '
21900 IF(IJ.EQ.5)G='G'
22000 202 IF(IJ.NE.2.AND.IJ.NE.4.AND.IJ.NE.6)WRITE(JOUT, 201),G
22100 201 FORMAT(2XA1,52('-'))
22200 209 FORMAT(4X49A1)
22300 210 FORMAT('+',4X49A1)
22400 C PRINTS LINES FOR SCRATCH.
22500
22600 5557 WRITE(JOUT, 60)
22700 J(1,1)=' '
22800 WRITE(JOUT, 5),J
22900 CC IF(JOUT.EQ.5)PAUSE
23000 111 CONTINUE
23100 DO 1111 K=1,6
23200 1111 IC(K)=0
23300 LR=1
23400 JGRP=6
23500 KGRP=2
23600 MPRINT=2
23700 DO 1000 IGRP=1,4
23800 KK=0
23900 DO 17 K=1,12,JGRP
24000 JJ=0
24100 DO 117 L=1,JGRP
24200 117 JJ=JJ+ISQ(K+L,2)
24300 KK=KK+1
24400 17 IC(KK)=JJ
24500 MM=0
24600 MCNT=0
24700 DO 19 NN=1,2
24800 JQQ=4-NN
24900 DO 19 I=JQQ,13
25000 DO 21 KK=1,KGRP
25100 DO 18 K=1,12,JGRP
25200 JJ=0
25300 DO 118 L=1,JGRP
25400 NI=I
25500 NR=L+K
25600 IF(NN.EQ.1)GO TO 118
25700 NI=NR
25800 NR=I
25900 118 JJ=ISQ(NR,NI)+JJ
26000 LL=I
26100 GO TO 18
26200 WRITE(JOUT, 400),KK,JGRP,JJ,IGRP,KGRP,K
26300 18 IF(IC(KK).EQ.JJ)GO TO 21
26400 GO TO 19
26500 21 CONTINUE
26600 LI=LL
26700 LR=1
26800 IF(NN.EQ.1)GO TO 221
26900 LI=1
27000 LR=LL
27100 221 IF(MM)GO TO 55
27200 MPRINT=MPRINT+1
27300 C COUNTS FOR STAFF PRINTOUT
27400 GO TO (11,22,33,44),IGRP
27500 11 WRITE(JOUT, 51)
27600 HEX=0
27700 GO TO 55
27800 22 WRITE(JOUT, 52)
27900 HEX=-10
28000 GO TO 55
28100 33 WRITE(JOUT, 53)
28200 HEX=-10
28300 GO TO 55
28400 44 WRITE(JOUT, 54)
28500 HEX=-10
28600 55 MM=-1
28700 IF(HEX.EQ.5)WRITE(JOUT, 51)
28800 HEX=HEX+1
28900 MCNT=MCNT+1
29000 WRITE(JOUT, 50),J(LR,LI)
29100 IF(MCNT.LT.7)GO TO 19
29200 MCNT=0
29300 MM=0
29400 C TO STAY IN 8 1/2" WIDTH ON PAPER
29500 19 CONTINUE
29600 JGRP=JGRP-1
29700 IF(IGRP.EQ.1)JGRP=4
29800 1000 KGRP=12/JGRP
29900 KREP=KREP-1
30000 IF(JOUT.EQ.5)GO TO 662
30100 WRITE(JOUT, 60)
30200 L=5-MPRINT/2
30300 DO 5555 K=1,L
30400 5555 WRITE(JOUT, 5556)
30500 IF(KREP)CALL EXIT
30600 WRITE(JOUT, 500)
30700 GO TO 10
30800 5556 FORMAT(/5(1X,80('-')/)/)
30900 51 FORMAT(/' HEXADS ....P0',$)
31000 52 FORMAT(/' TETRADS ...P0',$)
31100 53 FORMAT(/' TRIADS ....P0',$)
31200 54 FORMAT(/' DYADS .....P0',$)
31300 5 FORMAT(1XA4,2(1X6A4)/2(/6(1XA4,2(1X6A4)/)))
31400 1 FORMAT (72A1)
31500 444 FORMAT (10A5)
31600 50 FORMAT('+ = ',A3,$)
31700 60 FORMAT(1X10A5)
31800 66 FORMAT(1XA5,I2,3XI2)
31900 67 FORMAT(' GROUP SHORTENED TO ',I2)
32000 100 FORMAT(' TYPE 12 NOTES'/)
32100 500 FORMAT('1')
32200 400 FORMAT(6I)
32300 END
32350
32375
32400 SUBROUTINE MSS12
32500 COMMON INV(12),IR(12),N(12),J(13,13),ISCAL(12),IS2(12),
32600 1 INP2(72),INP(72),NRW
32700 1,IC(6),ISQ(25,25),NAME(10),INOT(49),JA(12)
32800 K=2
32900 L=2
33000 DO 1 M=1,24
33100 INP(MM)=J(K,L)
33200 IF(M.GT.12)GO TO 2
33300 K=K+1
33400 IF(K.LE.12)GO TO 1
33500 K=2
33600 GO TO 1
33700 2 L=L+1
33800 1 CONTINUE
33900 END
34000 C JUST BEGINNING OF IDEA!!!!
34100
34200
34300 SUBROUTINE RDWRT
34400 C TO READ AND RWITE TONE-ROW LIBRARY FILE
34500 COMMON INV(12),IR(12),N(12),J(13,13),ISCAL(12),IS2(12),
34600 1 INP2(72),INP(72),NRW
34700 1,IC(6),ISQ(25,25),NAME(10),INOT(49),JA(12)
34750 REWIND 1
34800 15 TYPE 10
34900 ACCEPT 2,NM
35000 IF(NM.EQ.' ')NM='ROWS'
35100 IF(NRW.EQ.'R')GO TO 1
35200 CC IF(LOOKD(NM))GO TO 1
35300 C 'LOOKD' LOOKS FOR .DAT FILE -- 'LOOK' LOOKS FOR NO EXT.
35400 CALL OFILE(1,NM)
35500 WRITE(1,2)NAME
35600 WRITE(1,3)INP2
35700 END FILE 1
35800 RETURN
35900 2 FORMAT(10A5)
36000 3 FORMAT(72A1)
36100 5 FORMAT(1X10A5)
36200 6 FORMAT(/' DO YOU WANT THIS ONE? '$)
36300 7 FORMAT(I,10A5)
36400 8 FORMAT(I,72A1)
36500 10 FORMAT(' TYPE FILE NAME-- '$)
36600 11 FORMAT(' TYPE IDENTITY NAME '$)
36700 1 CALL IFILE(1,NM)
36800 TYPE 11
36900 I=-1
37000 ACCEPT 2,(INP(M),M=1,10)
37100 IF(INP(1).EQ.' ')GO TO 4
37200 C <CR> TO GO THROUGH ALL NAMES.
37300 NM=INP(1)+INP(2)
37400 I=0
37500 4 READ(1,7,END=9)M,NAME
37600 IF(M.LT.99)REREAD 2,NAME
37700 IF(NAME(1).EQ.' ')GO TO 4
37800 C SO IT WILL IGNORE BLANK LINES (1ST 5 CHARS.)
37900 IF(I)GO TO 12
38000 IF(NM.EQ.NAME(1)+NAME(2))GO TO 12
38100 M='N'
38200 GO TO 14
38300 12 TYPE 5,NAME
38400 13 TYPE 6
38500 ACCEPT 3,M
38600 14 READ(1,8)L,INP2
38700 IF(L.LT.99)REREAD 1,INP2
38800 IF(M.NE.'Y')GO TO 4
38900 RETURN
39000 9 TYPE 90
39100 90 FORMAT(' --- NAME NOT FOUND! -----'/)
39200 GO TO 15
39300 END